'FRAGGLE.BAS by Bill Buckels 1990
'Written in QuickBASIC Version 4.5
'produces and displays image fragments 
'created from BASIC BSAVED MED RES CGA IMAGES
'Revised 2007 as a pure QuickBasic Program
'Removed PCX support because not written in QuickBasic
'Added resave back to BSaved Image
'Revised program structure for readability
'Increased error handling and added error messages
'Removed automatic naming from basename.
'Now using the .PUT extension when saving.
'Added 8 x 8 Block Based Fragments for C64 Style Saves
'Revised May 2008 to create silly things
'Revised June 2008 to create Apple II Screen Size Fragments

DEFINT A-Z
'allocate memory for picture buffer
DIM PIC(8002)                              'picture buffer
'constants for keypress values
NUL$ = CHR$(0)
UP$ = NUL$ + CHR$(72)
DN$ = NUL$ + CHR$(80)
LT$ = NUL$ + CHR$(75)
RT$ = NUL$ + CHR$(77)
ESC$ = CHR$(27)
ENTER$ = CHR$(13)
'constants for keypress status
FLAG = 0
ZERO = 0
ONE =  1
TWO =  2
DONE = 3
ABORT = 0

ERRORLEVEL = 0
ON ERROR GOTO ERRORHANDLE

SCREEN 1

DO

 'bounds of the screen
 X1 = 0: X2 = 319: Y1 = 0: Y2 = 199
 
 GOSUB DRAWMENU 'Menu Routine
 GOSUB GETCHOICE
 
 IF ERRORLEVEL = 0 THEN 
	SELECT CASE PICTYPE%
	CASE 1,5
		'if we have been asked to fraggle
		GOSUB VARFRAG
	CASE 2
		'if we're not fragging we're viewing so we stop and wait in that case
		KEYPRESS$ = INPUT$(1)
		
	CASE 3
		'make a menu chip
		GOSUB FIXEDFRAG 
        CASE 6
                GOSUB SILLYFRAG 
        CASE 7
                GOSUB APPLEFRAG

	CASE 4 'bsave fragment
		GOSUB RESAVE

	END SELECT
 END IF
 
 ABORT = ZERO
 ERRORLEVEL = 0
LOOP UNTIL PICNAME$ = "FINISHED"
END


DRAWMENU:
 
 CLS

 LINE (2,2)-(317,102),2,b
 LINE (0,0)-(319,102),1,b
 LOCATE 2,2
 PRINT " FRAGGLE(C)
 LOCATE 3,2
 PRINT " Copyright Bill Buckels 1990-2008"
 LOCATE 5,2
 PRINT "    1)   Fraggle a BSaved Image"
 LOCATE 6,2
 PRINT "    2)   Load an Image Fragment"
 LOCATE 7,2
 PRINT "    3)   Fraggle 88 x 52 from BSaved"
 LOCATE 8, 2
 PRINT "    4)   BSave a Fraggled Image"
 LOCATE 9, 2
 PRINT "    5)   Fraggle C64 Style from BSaved"
 LOCATE 10,2
 PRINT "    6)   Fraggle Silly Things"
 LOCATE 11,2
 PRINT "    7)   Fraggle A2 Style from BSaved "

 ' menu explanations 

 LINE (2,104)-(317,197),1,b
 LINE (0,104)-(319,199),2,b
 LOCATE 15, 2
 PRINT " Summary of Fraggle Hot Keys:"
 LOCATE 17, 2
 PRINT " R      - Reverse Video"
 LOCATE 18, 2
 PRINT " L      - Adjust Vertical 1 pixel"
 LOCATE 19, 2
 PRINT " W      - Adjust Horizontal 1 pixel"
 LOCATE 20, 2
 PRINT " ESC    - Abandon Operation"
 LOCATE 21, 2
 PRINT " ENTER  - 1st and 2nd corners"
 LOCATE 22, 2
 PRINT "          Save Fragment"
 LOCATE 23, 2
 PRINT " ARROWS - Change Clip Position";

 'get input
 ' LOCATE 12,2
 ' PRINT " Select from the above Menu options.";


RETURN


GETCHOICE:
  'menu input subroutine
  PICTYPE$ = INPUT$(1)
  PICTYPE% = VAL(PICTYPE$)
  SELECT CASE PICTYPE%
  CASE 1, 3, 5, 6, 7
        CLS
  	PRINT "Raw Load"
	FILES "*.BAS"
  CASE 2, 4
        CLS
 	PRINT "Image Fragment Load"
    	FILES "*.PUT" 
  CASE ELSE
     	END
  END SELECT
  
  LINE(0,180)- (319,195),0,BF
  LINE(0,180)- (319,195),2,B
  LINE(2,182)- (317,193),1,B
  LOCATE 24,2
  SELECT CASE PICTYPE%
  CASE 1, 3, 5, 6, 7
  	INPUT " PICTURE"; PICNAME$
  CASE 2, 4
  	INPUT " FRAGMENT"; PICNAME$
  END SELECT
  
  IF PICNAME$ = "" THEN
  	PICTYPE%=0
  ELSE
    	CLS
    	GOSUB LOADPIC
  END IF     

RETURN      


LOADPIC:
  ' picture loader subroutine 
  SELECT CASE PICTYPE%

  CASE 1, 3, 5, 6, 7  'Raw Data
      SEGMENT = &HB800              'Use Screen Segment
      OFFSET = &H0
      DEF SEG = SEGMENT
      BLOAD PICNAME$, OFFSET        'Bload the Picture

  CASE 2, 4
      'load image fragments
      SEGMENT = VARSEG(PIC(0))
      OFFSET = VARPTR(PIC(0))

      DEF SEG = SEGMENT
      BLOAD PICNAME$, OFFSET
      XTAB = INT((640 - PIC(0)) / 4)   'center horizontally
      PUT (XTAB, 0), PIC, PSET         'put picture

  END SELECT
  DEF SEG  'Go back to original segment
  
  IF ERRORLEVEL > 0 THEN
      CLS
      LINE (0,0)-(319,24),0,BF
      LINE (0,0)-(319,24),1,B
      LOCATE 2,2
      PRINT PICNAME$ + " NOT loaded. Press a key..."
      A$ = INPUT$(1)     
  END IF
  
RETURN


VARFRAG:
  ' subroutine for saving variable size image fragments
  ' backup the picture
  GET (X1, Y1)-(X2, Y2), PIC
  'and do an elastic box with a DOTTED line in two colors 
  LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
  LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
 
  IF PICTYPE% = 5 THEN
       INCR% = 8
  ELSE
       INCR% = 4 
  END IF
 
 
  ENTER% = 1 'FRAG PART ONE- SET THE TOP LEFT CORNER
  FLAG = 0
  WHILE FLAG = 0
    KEYPRESS$ = INKEY$
    SELECT CASE KEYPRESS$
    CASE "R", "r" 'reverse video
	PUT (0,0),PIC,PRESET
	GET (0,0)-(319,199), PIC
	PUT (0,0),PIC,PSET
	FLAG=ONE
    CASE "L", "l" 'fine tuning
        IF INCR% = 4 THEN
	  IF ENTER% = 1 THEN ' TOP LEFT CORNER
	      IF NOT Y1 = 0 THEN
		 Y1 = Y1 - 1
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	  ELSE  ' BOTTOM RIGHT CORNER
	      IF Y2 > (Y1 + 4) THEN
		 Y2 = Y2 - 1
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	  END IF
	END IF
    CASE "W", "w" 
        IF INCR% = 4 THEN
	  IF ENTER% = 1 THEN ' TOP LEFT CORNER
	      IF NOT X1 = 0 THEN
		 X1 = X1 - 1
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	  ELSE  ' BOTTOM RIGHT CORNER
	      IF X2 > (X1 + 4) THEN
		 X2 = X2 - 1
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	  END IF
	END IF
    CASE UP$ 'up arrow
	IF ENTER% = 1 THEN ' TOP LEFT CORNER
	      IF NOT Y1 = 0 THEN
		 Y1 = Y1 - INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	ELSE  ' BOTTOM RIGHT CORNER
	      IF Y2 > (Y1 + INCR%) THEN
		 Y2 = Y2 - INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	END IF
    CASE DN$ 'down arrow
	IF ENTER% = 1 THEN ' TOP LEFT CORNER
	      IF NOT Y1 > Y2 - INCR% THEN
		 Y1 = Y1 + INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	ELSE  ' BOTTOM RIGHT CORNER
	      IF NOT Y2 = 199 THEN
		 Y2 = Y2 + INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	END IF
    CASE LT$ 'left arrow
	IF ENTER% = 1 THEN ' TOP LEFT CORNER
	      IF NOT X1 = 0 THEN
		 X1 = X1 - INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	ELSE  ' BOTTOM RIGHT CORNER
	      IF X2 > (X1 + INCR%) THEN
		 X2 = X2 - INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	END IF
    CASE RT$ 'right arrow
	IF ENTER% = 1 THEN ' TOP LEFT CORNER
	      IF NOT X1 > X2 - INCR% THEN
		 X1 = X1 + INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	ELSE  ' BOTTOM RIGHT CORNER
	      IF NOT X2 = 319 THEN
		 X2 = X2 + INCR%
		 PUT (0, 0), PIC, PSET
		 FLAG = ONE
	      END IF
	END IF
    CASE ESC$ 
	ABORT = TWO
	FLAG = DONE
    CASE ENTER$ 
	ENTER% = ENTER% + 1 'FRAG PART TWO - SET THE BOTTOM RIGHT CORNER
	IF ENTER% > 2 THEN FLAG = DONE
    END SELECT
    IF FLAG = ONE THEN
	'change the position of the elastic box
	'based on the last arrow or positional keypress 
	LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
	LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
	FLAG = 0
    END IF
  WEND
 
  IF ABORT = ZERO THEN
      GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
  END IF

RETURN



FIXEDFRAG:
  ' subroutine for saving 88 x 52 fixed size image fragments
  ' or 24 x 21 Double C4 Sprite
  ' backup the picture
  GET (X1, Y1)-(X2, Y2), PIC
  ' use a printshop compatible image size
  ' 88 x 52
  X1=0 : X2=87 : Y1 = 0 : Y2=51
  
  
  'and do an elastic box with a DOTTED line
  'in two colors to show-up regardless
  LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
  LINE (X1, Y1)-(X2, Y2), 3, B, &H5555

  FLAG = 0

  WHILE FLAG = 0
    KEYPRESS$ = INKEY$
    
    SELECT CASE KEYPRESS$
    CASE "R", "r"  'reverse video
		PUT (0,0),PIC,PRESET
		GET (0,0)-(319,199), PIC
		PUT (0,0),PIC,PSET
		FLAG=ONE
    CASE UP$ 
              IF NOT Y1 = 0 THEN
		Y1 = Y1 - 4
		Y2 = Y2 - 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE DN$  'down arrow
              IF NOT (Y2+4)>199 THEN
		Y2 = Y2 + 4
		Y1 = Y1 + 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE LT$  'left arrow
              IF NOT X1 = 0 THEN
		X1 = X1 - 4
		X2 = X2 - 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE RT$  'right arrow
              IF NOT (X2+4)>319 THEN
		X1 = X1 + 4
		X2 = X2 + 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE ESC$ 
		ABORT = TWO
		FLAG = DONE
    CASE ENTER$ 
		FLAG = DONE
    END SELECT
    
    IF FLAG = ONE THEN
	'change the position of the elastic box
	'based on the last arrow or positional keypress 
	LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
	LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
	FLAG = 0
    END IF
  WEND
  
  IF ABORT = ZERO THEN
  	GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
  END IF

RETURN

SILLYFRAG:
  
  GET (X1, Y1)-(X2, Y2), PIC
  X1=14 : X2=209: Y1 = 8 : Y2=71
  SUFFIX$ = "1"
  
  'and do an elastic box with a DOTTED line
  'in two colors to show-up regardless
  LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
  LINE (X1, Y1)-(X2, Y2), 3, B, &H5555

  FLAG = 0

  WHILE FLAG = 0
    KEYPRESS$ = INKEY$
    SELECT CASE KEYPRESS$
    CASE ESC$ 
		ABORT = TWO
		FLAG = DONE
    CASE ENTER$ 
		FLAG = DONE
    END SELECT
  WEND
  
  IF ABORT = ZERO THEN
  	GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
  	GOSUB LOADPIC
  	GET (0, 0)-(319, 199), PIC
  	SUFFIX$ = "2"
  	Y1 = 72 : Y2=141
  	GOSUB SAVEFRAG 
  	GOSUB LOADPIC
  	GET (0, 0)-(319, 199), PIC
  	SUFFIX$ = "3"
  	Y1 = 142: Y2=199
  	GOSUB SAVEFRAG 
  END IF

RETURN

APPLEFRAG:
  ' subroutine for saving 280 x 192 fixed size image fragments
   ' backup the picture
  GET (X1, Y1)-(X2, Y2), PIC
   X1=0 : X2=279 : Y1 = 0 : Y2=191
   
  'and do an elastic box with a DOTTED line
  'in two colors to show-up regardless
  LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
  LINE (X1, Y1)-(X2, Y2), 3, B, &H5555

  FLAG = 0

  WHILE FLAG = 0
    KEYPRESS$ = INKEY$
    
    SELECT CASE KEYPRESS$
    CASE "R", "r"  'reverse video
		PUT (0,0),PIC,PRESET
		GET (0,0)-(319,199), PIC
		PUT (0,0),PIC,PSET
		FLAG=ONE
    CASE "L", "l"  
              IF NOT Y1 = 0 THEN
		Y1 = Y1 - 1
		Y2 = Y2 - 1
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE "W", "w"
              IF NOT X1 = 0 THEN
		X1 = X1 - 1
		X2 = X2 - 1
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF    
    CASE UP$ 
              IF NOT Y1 = 0 THEN
		Y1 = Y1 - 4
		Y2 = Y2 - 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE DN$  'down arrow
              IF NOT (Y2+4)>199 THEN
		Y2 = Y2 + 4
		Y1 = Y1 + 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE LT$  'left arrow
              IF NOT X1 = 0 THEN
		X1 = X1 - 4
		X2 = X2 - 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE RT$  'right arrow
              IF NOT (X2+4)>319 THEN
		X1 = X1 + 4
		X2 = X2 + 4
		PUT (0, 0), PIC, PSET
		FLAG = ONE
              END IF
    CASE ESC$ 
		ABORT = TWO
		FLAG = DONE
    CASE ENTER$ 
		FLAG = DONE
    END SELECT
    
    IF FLAG = ONE THEN
	'change the position of the elastic box
	'based on the last arrow or positional keypress 
	LINE (X1, Y1)-(X2, Y2), 2, B, &HAAAA
	LINE (X1, Y1)-(X2, Y2), 3, B, &H5555
	FLAG = 0
    END IF
  WEND
  
  IF ABORT = ZERO THEN
  	GOSUB SAVEFRAG 'SAVE IF ESCAPE WAS NOT PRESSED
  END IF

RETURN




SAVEFRAG:
  'subroutine for saving an image fragment
  'blot the screen one last time
  'give the file name from the a .PUT extension
  PUT (0, 0), PIC, PSET
  GET (X1, Y1)-(X2, Y2), PIC
  LINE (0,0)-(319,24),0,BF
  LINE (0,0)-(319,24),1,B
  LOCATE 2,2
  IF PICTYPE% = 6 THEN
        NEWPIC$ = PICNAME$
        PRINT "FRAGMENT NAME"; NEWPIC$ 
  ELSE
  	INPUT "FRAGMENT NAME"; NEWPIC$
  	IF NEWPIC$ = "" THEN RETURN
  END IF
  
  FRAG$ = NEWPIC$
  NEWPIC$ = ""
  
  A$ = ""
  A% = 1
  'parse until the period
  WHILE NOT A$ = "."
    IF A% < LEN(FRAG$)+1 THEN
      A$ = MID$(FRAG$, A%, 1)
    ELSE
      A$ = "."
    END IF
    IF PICTYPE% = 6 AND A$ = "." THEN
       NEWPIC$ = NEWPIC$ + SUFFIX$
    END IF
    NEWPIC$ = NEWPIC$ + A$
    A% = A% + 1
  WEND
  NEWPIC$ = NEWPIC$ + "PUT"
  'put the window into an array
  'then point to the array
  'and save it to disk
  
  SEGMENT = VARSEG(PIC(0))
  OFFSET = VARPTR(PIC(0))
  DEF SEG = SEGMENT
  'find the width and the height
  'and calculate the length of the array
  'raster lines break on byte boundaries
  'the array header is two words in length
  WIDE = INT((((X2 - X1) * 2) + 7) / 8)
  HIGH = (Y2 - Y1)+1
  PICSIZE = 4 + (WIDE * HIGH) +1
  BSAVE NEWPIC$, OFFSET, PICSIZE
  DEF SEG
  
  CLS
  LINE (0,0)-(319,24),0,BF
  LINE (0,0)-(319,24),1,B
  LOCATE 2,2
  IF ERRORLEVEL = 0 THEN
    PRINT NEWPIC$ + " saved. Press a key..."
  ELSE
    PRINT NEWPIC$ + " NOT saved. Press a key..."
  END IF
  A$ = INPUT$(1)  
      
RETURN             
  
RESAVE:
  'subroutine for saving a Bsaved Image
  'from an image fragment
  GET (X1, Y1)-(X2, Y2), PIC
  LINE (0,0)-(319,24),0,BF
  LINE (0,0)-(319,24),1,B
  LOCATE 2,2
  INPUT "NEW NAME"; NEWPIC$
  IF NEWPIC$ = "" THEN RETURN
 
  FRAG$ = NEWPIC$
  NEWPIC$ = ""
 
  A$ = ""
  A% = 1
  'parse until the period
  WHILE NOT A$ = "."
    IF A% < LEN(FRAG$)+1 THEN
      A$ = MID$(FRAG$, A%, 1)
    ELSE
      A$ = "."
    END IF
    NEWPIC$ = NEWPIC$ + A$
    A% = A% + 1
  WEND
  NEWPIC$ = NEWPIC$ + "BAS"
 
  'restore the screen
  'and save it to disk
  PUT (0, 0), PIC, PSET
  SEGMENT = &HB800              'Use Screen Segment
  OFFSET = &H0
  DEF SEG = SEGMENT
  PICSIZE = 16384 
  BSAVE NEWPIC$, OFFSET, PICSIZE
  DEF SEG

  CLS
  LINE (0,0)-(319,24),0,BF
  LINE (0,0)-(319,24),1,B
  LOCATE 2,2
  IF ERRORLEVEL = 0 THEN
    PRINT NEWPIC$ + " saved. Press a key..."
  ELSE
    PRINT NEWPIC$ + " NOT saved. Press a key..."
  END IF
  A$ = INPUT$(1)
  
RETURN               

ERRORHANDLE:
     BEEP
     ERRORLEVEL = 1
     RESUME NEXT